COMMENT ⊗   VALID 00018 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	.SBTTL SMALL BLOCK ALLOCATOR
C00008 00003	 Definitions of fields
C00011 00004	 DEFSPC
C00013 00005	 DATA AREA
C00014 00006	 MAPPTR, MKRTJM, MARKR0, LNKMTH
C00022 00007	 MARKPH, MKROUT
C00024 00008	ROUTINE CMPSP,<SPC>
C00028 00009	ROUTINE COMPACT
C00030 00010	 SWEEP
C00034 00011	 GC, NOGC, YESGC, NOCMP, YESCMP
C00037 00012	 GETSBK, GETBLK, GETSID, PTRSID
C00041 00013	 FREBLK, FRESBK
C00043 00014	 NEWSPC, SETSPC
C00045 00015	 ADDBUF
C00048 00016	 Standard spaces, SBINIT, Marking methods: MCELL, MARKQ
C00054 00017	.IFNZ	SMBDBG		Test routine
C00056 00018	 Known bugs
C00058 ENDMK
C⊗;
.SBTTL SMALL BLOCK ALLOCATOR
;Coded by RHT 9-Sept-1974
;Debugged & fixed by ARG 11/76

SMBDBG == 0	;1 => WE ARE DEBUGGING (PUT IN TEST ROUTINE)

COMMENT ⊗

Overview: The basic idea is to break up large blocks of storage into
smaller, fixed size blocks, and then administer them.  The routines
given here provide a facility whereby a user can have a number of
different "spaces" of fixed size blocks.  Each space is described by
an approximately 10 word space descriptor.  All these space
descriptors are linked together on a big chain (SIDLST), and each
space is assumed to have asociated with it a unique 8-bit number
(thus allowing up to 256 spaces).  Each space descriptor owns a
linked list of buffers; each buffer contains a number of blocks.
Each space may be either collectable or uncollectable.  Any block may
be released explicitly, although if the space is collectable, this
may be unwise.  Also, collectable spaces are compacted by the
garbage collector.  As an efficiency measure, the first few indices
[of what? - RF] (now, 1-10) are also kept in a table (SIDTBL). 
 
 Blocks are allocated by the routines GETBLK & GETSBK:
 
 	MOV	#IDCODE,R0	 ;IDCODE is the 8-bit code for a space
 	JSR	PC,GETBLK	 ;
 
 	MOV	#SPCDSC,R0	 ;SPCDSC is the address of the space
 	JSR	PC,GETSBK	 ;descriptor
 
In either case, a pointer to a new block is returned in R0.  If need
be, the free space routine will call the garbage collector to get
more space or (if the space is not collectable or garbage collection
is disabled) it will call the large block routines to get another
buffer.  If garbage collection fails to produce a goodly surplus of
blocks for some space, then additional buffers of new blocks will be
obtained. 
 
Each small block has the following format:

 		TAG,,ID		 tag is used in garbage collecting
 	R0 →→	WORD 0		 this is the word pointed to by getblk
 		:
 		WORD n
 
Blocks are zeroed before being returned.  Although this is sometimes
a bit extra overhead, it does prevent bugs and avoids the necessity
for explicit clears all over the place. 
 
Blocks are freed by the routines FREBLK & FRESBK:
 
 	MOV	BLOCK,R0	 ;R0 ← block to free
 	JSR	PC,FREBLK
 
 	MOV	BLOCK,R0	 ;R0 ← block to free
 	MOV	#SPCDSC,R1	 ;R1 ← space descriptor
 	JSR	PC,FRESBK
 
The macro 
 	 DEFSPC ID,MMRT,SZ,NPB,GCF,NMN,NPC
may be used to declare compiled-in space descriptors.  Please see the
comment on routine MAPPTR for additional instuctions for declaring
spaces. 

NOTE:  These routines are set up to allow for compacting of 
free space & release of excess buffer blocks.  However, the routine
for doing the actual release of excess blocks is not included yet
although the place it is to go is clearly marked (in COMPACT).  Therefore,
it is suggested that the flag CMPOK be left OFF for the time being.
	
	Release routine added (to SWP.) 11/76 ARG 
⊗
; Definitions of fields

;SPACE DESCRIPTOR

	II == 0
	XX	IDFLAG	;Actually a byte; gets put in the ID part of tag word
	XX	MAPRTN	;Routine to be called when marking
	XX	SIZE	;How many words for a value cell in this type block.
	XX	NPERB	;Number of blocks per buffer
	XX	GCFG	;Set if this is a collectable area
	XX	NMIN	;Min number of free blocks to be returned by GC
	XX	NPCT	;Min % of free blocks to be returned by GC
	XX	NXTSID	;Next space descriptor on ID chain
	XX	FFREE	;List of free blocks
	XX	FSTBUF	;Oldest buffer
	XX	LSTBUF	;Newest buffer
	XX	NALLOC	;Number of blocks allocated
	XX	NFREE	;Number of blocks free
	SPCHDR == II	;Number of bytes in a space descriptor

; BUFFER HEADER
	II == 0
	XX	NXTBUF	;Next buffer in this space
	XX	PRVBUF	;Previous buffer in this space
	XX	LSTBLK	;Address of last block in this buffer
	XX	FSTBLK	;Address of first block in this buffer, word 0.
	BUFHDR == II	;Number of bytes in a buffer header

; SMALL BLOCK
	II == 0
	TAG == -1	; ≠ 0 means in use (used by GC)
	TAGID == -2	;Holds an "ID" for this record
	XX	WORD0	;First data word
                        ;Note that if this block is free, the first data
                        ;word is used to maintain a list of free
                        ;blocks. 

; GC METHODS
	II == 0
	XX	METH	;Address of routine to call
	XX	NXTMTH	;Next CG method on chain

; Marking method macro
       .MACRO MMETH ROUT
	ROUT
	0
       .ENDM
; DEFSPC

; Assemble-time spaces
       .IF2
	SIDHED == SIDCHN ;Sets SIDHED to the final value of SIDCHN
       .ENDC

SIDCNT == 0		;Number of assembled-in space descriptors
SIDCHN == 0		;Linkage for assembled-in space descriptors

COMMENT ⊗ Declare assembled-in space descriptors: Makes a space
descriptor.  ID is given the number of the space.  MMRT is the map
routine, SZ the size, NPB the number of blocks per buffer, GCF is set
if the area is not to be collected, NMN is the minimum number of free
blocks that GC should return, NPC is the minimum percent of free
blocks that GC should return.  ⊗

.MACRO DEFSPC ID,MMRT,SZ,NPB,GCF,NMN,NPC
    .IFNDF ID
	SIDCNT==SIDCNT+1
	ID==SIDCNT
    .ENDC
    II==.
    .BLKW SPCHDR/2
	TT	IDFLAG,ID
	TT	MAPRTN,MMRT
	TT	SIZE,SZ
	TT	NPERB,NPB
	TT	GCFG,GCF
	TT	NMIN,NMN
	TT	NPCT,NPC
	TT	NXTSID,SIDCHN
	TT	FFREE,0
	TT	FSTBUF,0
	TT	LSTBUF,0
	TT	NALLOC,0
	TT	NFREE,0
    SIDCHN == II
    .=II+SPCHDR
      .IF2
	.IFGE MAXIDF-ID
	  PUTLOC <ID*2 + SIDTBL>,SIDCHN
	.ENDC
      .ENDC
.ENDM

; DATA AREA

SBEVT:	0		;Interlocking event
MMETHS:	0		;Header of list of marking methods
GCOK:	0		;0 => GC is OK; else count of those opposed to it.
GCDONE: 0		;Count of times GC performed
CMPOK:	0		;0 => compacting is OK; else count of those opposed
SIDLST:			;List of space descriptor blocks
	.IF1		;Let pass 2 of assemble fix this up
		0
	.ENDC
	.IF2
		SIDHED
	.ENDC

MAXIDF == 30		;Max index into SIDTBL
SIDTBL:	0		;Table of space descriptors for efficiency
	.BLKB MAXIDF
; MAPPTR, MKRTJM, MARKR0, LNKMTH

ROUTINE MAPPTR,<ROUT>	
 
COMMENT ⊗ ROUT takes a single parameter (in R0) which is a pointer to
a small block.  It returns (in R0) a pointer value which is to be
stored back in the pointer cell.  This allows MAPPTR to be called
twice to do essentially different things.  The first time, during
marking, ROUT will be MKROUT.  The second time, during compacting,
it will be something else. 

MAPPTR runs down a list of "marking methods" (MMETHS).  Each method
is assumed to be responsible for some batch of "top level" pointers
(i.e., variables in the user's program that point to small blocks). 
For each pointer it finds, a method should call the routine MARKR0
(via JSR PC).  Thus, each marking method should have the form

 	METH:	R←#<first pointer>
 		WHILE R≠NULL DO
 			BEGIN
 			R0←(R);
 			JSR PC,MARKR0;
 			(R)←R0;
 			R←#<next pointer>;
 			END;
 		RETURN;
 
MARKR0 determines the type of the record (finds its space descriptor).
It then does a 

 		JSR	PC,@MAPRTN(<space>)

MAPRTN takes as a parameter a single block pointer in R0 & returns(in
R0) a pointer to the same block (In the case of compacting,
this may be a different value).  The routine is responsible for
"marking" the block and any pointer subfields of the block.  If there
are no pointer subfields, then the system routine MKRTJM ( JMP
@ROUT(RF) ) may be used.  If there are pointer subfields, then the
mark routine needs to be more complicated:
 
 		IF TAG(R0) THEN RTS PC;	comment if block handled, then return;
 		JSR	PC,@2(RF);	comment calls ROUT;
 		PUSH R;
 		R←R0;
 		∀ <field> | <field> is a pointer subfield of R DO
 			BEGIN
 			R0←<field>
 			JSR	PC,MARKR0;
 			<field>←R0;
 			end;
 		R0←R;
 		POP R;
 		RTS PC;
 
Note: it may be a good idea to change the conventions here a bit to
(1) pass a pointer at a record pointer & (2) let markr0 assume
responsibility for storing the updated pointer.  The advantage of
such a course is that it allows iterative marking of long lists, thus
avoiding possible pdl overflows. (P.S. RHT loses again. Unless some
totally new data structures are added to the runtime system everything
is fine as is. I've changed some current routine (e.g MCELL pg16) to
be iterative. They were recursive. ----  arg  11/76 )


NOTE: There is a BUG in COMPACT.  The test on the tag inside the
maprtn may cause a record to be skipped over that has pointer
subfields to garbage (ie moved records).  Fix this later.
LEAVE CMPOK OFF 					RHT

FURTHER NOTE: RHT is out to lunch here. We don't have any data types
allocated by the small blocks allocator where the above becomes a problem.
Cells might have been a problem, but they are only used to create
simple lists. His compacter had several other bugs which are now
fixed. CMPOK is now ON.
						ARG   11/76

EXAMPLE: Consider a CONS cell:

DEFSPC	CNSCLL,CNSMRK,2,100,0,40,20
	II == 0
	XX	CAR
	XX	CDR

; This is the map routine associated with the CONS cell space:
CNSMRK:	TSTB	TAG(R0)		
	BNE	CNSM.X
	JSR	PC,@2(RF)	; calls ROUT
	MOV	R2,-(SP)	; 
	MOV	R0,R2		;SAVE RETN VALUE
	MOV	CAR(R2),R0	; MARK CAR
	JSR	PC,MARKR0
	MOV	R0,CAR(R2)
	MOV	CDR(R2),R0	;MARK CDR
	JSR	PC,MARKR0
	MOV	R0,CDR(R2)
	MOV	R2,R0		;RET VAL BACK
	MOV	(SP)+,R2	;PUT R2 BACK
CNSM.X:	RTS	PC		;RETURN

CELLS:	BLKW	10		;A BLOCK OF 10 CELL POINTERS

;This is the marking method for cells:
MCELLS:	MOV	R2,-(SP)	;
MCL.1:	MOV	#CELLS+20,R2	;WILL LOOP THROUGH
	MOV	-(R2),R0	;PICK UP POINTER
	JSR	PC,MARKR0	;MARK IT
	MOV	R0,(R2)		;PUT POINTER AWAY
	CMP	R0,#CELLS	;DONE YET ?
	BGT	MCL.1		;NOPE
	RTS	PC		;YES

MCLNK:	MMETH	MCELLS		;SPACE FOR LINK (IMPURE CODE)

;; ** next two lines go somewhere into initialization code
	MOV	#MCLNK,R0
	JSR	PC,LNKMTH
;; END OF EXAMPLE

⊗

;MAPPTR:	;(IN CASE YOU HAD FORGOTTEN)
	MOV	R2,-(SP)	;
	MOV	MMETHS,R2	;LIST OF MARKING METHS
	BEQ	2$		;DONE??
1$:	CALL	@METH(R2),<ROUT(RF)>
	MOV	NXTMTH(R2),R2	;NEXT METHOD
	BNE	1$		;ITERATE
2$:	MOV	(SP)+,R2	;
	RTS	PC		;RETURN

;The appropriate marking intrinsic for spaces whose blocks contain
;no pointer subfields:
MKRTJM:	JMP	@ROUT(RF)	;

MARKR0:	;This will be called by each marking method:
	TST	R0		;DON'T MARK A NULL
	BEQ	1$		;
	JSR	PC,PTRSID	;GETS SPACE DESCRIPTOR INTO R1
	JSR	PC,@MAPRTN(R1)	;CALL APPROPRIATE MARKING INTRINSIC
1$:	RTS	PC

; Add a method (in R0) to the "MMETHS" list:
LNKMTH:	MOV	MMETHS,NXTMTH(R0)
	MOV	R0,MMETHS
	RTS	PC
; MARKPH, MKROUT

ROUTINE MARKPH		;The marking phase of garbage collection
	MOV	R2,-(SP)	;
	MOV	R3,-(SP)	;
	MOV	SIDLST,R2	;ALL SIZES
	BEQ	5$		;DONE ALREADY??
1$:	TST	GCFG(R2)	;A GC SPACE??
	BEQ	4$		;NO, GO ON TO NEXT
	MOV	SIZE(R2),R3	;
	INC	R3		;ONE FOR TAG WORD
	ASL	R3		;WORDS TO BYTES
	MOV	FSTBUF(R2),R1	;CLEAR THIS BUFFER
	BEQ	4$		;IF THERE IS ONE
2$:	MOV	FSTBLK(R1),R0	;FIRST BLOCK
3$:	CLRB	TAG(R0)		;CLEAR TAG
	ADD	R3,R0		;BUMP POINTER TO NEXT
	CMP	R0,LSTBLK(R1)	;DONE THIS BUFFER?
	BLE	3$		;If not keep going
	MOV	NXTBUF(R1),R1	;ON TO NEXT BUFFER
	BNE	2$		;IF WE HAVE ONE
4$:	MOV	NXTSID(R2),R2	;GO ON TO NEXT SPACE
	BNE	1$		;

	CALL	MAPPTR,<#MKROUT> ;DO THE ACTUAL MARKING
	
5$:	MOV	(SP)+,R3	;RESTORE
	MOV	(SP)+,R2
	RTS	PC

MKROUT:	MOVB	#377,TAG(R0)	;
	RTS	PC		;

ROUTINE CMPSP,<SPC>

; Performs all data moving required to compact one size space

	MOV	R2,-(SP)	;SAVE SOME ACS
	MOV	R3,-(SP)	;
	MOV	R4,-(SP)	;
	MOV	SPC(RF),R2	;SPACE DSCR
	MOV	FSTBUF(R2),R3	;OLDEST
	MOV	LSTBUF(R2),R4	;NEWEST
	CMP	R3,R4		;See if there's at least two buffers
	BEQ	3$		;If not punt
	JSR	PC,10$		;First FREE INTO R1
				;MAY MODIFY R3
	BEQ	3$		;NO FREE
	JSR	PC,20$		;GET A RECORD TO MOVE (last used)
				;INTO R0 (MAY MODIFY R4)
	BEQ	3$		;
1$:	MOV	R1,-(SP)	;SAVE THESE
	MOV	R0,-(SP)	;
	MOVB	#377,TAG(R1)	;Old free now being used
	CLRB	TAG(R0)		;Old used now free
	MOV	SIZE(R2),R2	;
2$:	MOV	(R0)+,(R1)+	;COPY RECORD
	SOB	R2, 2$		;COUNT DOWN TIL DONE
	MOV	SPC(RF),R2	;YES
	MOV	(SP)+,R0	;GET ACS BACK
	MOV	(SP)+,R1	;
	MOV	R1,WORD0(R0)	;POINT AT THIS ONE
	JSR	PC,12$		;NEXT FREE
	BEQ	3$
	JSR	PC,22$		;NEXT RECORD
	BNE	1$		;PROCESS THAT ONE
3$:
	MOV	(SP)+,R4	;
	MOV	(SP)+,R3	;
	MOV	(SP)+,R2
	RTS	PC

10$:	MOV	FSTBLK(R3),R1	;FIND A FREE BLOCK
11$:	TSTB	TAG(R1)		;FREE
	BEQ	14$		;YES
12$:	ADD	SIZE(R2),R1	;LOOK AT NEXT
	ADD	SIZE(R2),R1	;ADD TWICE SINCE WANT TRUE ADDRESS
	TST	(R1)+		;ADD IN TAG WORD OFFSET
	CMP	R1,LSTBLK(R3)	;MORE TO TRY??
	BLE	11$		;TRY AGAIN
	MOV	NXTBUF(R3),R3	;NEXT NEWEST BUFFER
	BEQ	13$		;LOOK THERE
	CMP	R3,R4		;IF NOT TO THE used record SUPPLIER
	BNE	10$
13$:	CLR	R1
14$:	TST	R1		;GET FLAGS CORRECT
	RTS	PC


20$:	MOV	LSTBLK(R4),R0	;FIND A FULL BLOCK
21$:	TSTB	TAG(R0)		;FULL
	BNE	24$		;YES
22$:	SUB	SIZE(R2),R0	;LOOK AT NEXT
	SUB	SIZE(R2),R0	;Subtrct TWICE SINCE WANT TRUE ADDRESS
	TST	-(R0)		;Subtract TAG WORD OFFSET
	CMP	R0,FSTBLK(R4)	;MORE TO TRY??
	BGE	21$		;TRY AGAIN
	MOV	PRVBUF(R4),R4	;NEXT NEWEST BUFFER
	BEQ	23$		;LOOK THERE
	CMP	R3,R4		;IF NOT TO THE FREE SUPPLIER
	BNE	20$
23$:	CLR	R0
24$:	RTS	PC
ROUTINE COMPACT
	MOV	R2,-(SP)	
	MOV	SIDLST,R2	;LIST OF ALL SIZES
	BEQ	3$		;NULL LIST??
1$:	TST	GCFG(R2)	;COLLECTABLE??
	BEQ	2$		;BR IF NOT
	CALL	CMPSP,<R2>	;COMPACT THIS SPACE
2$:	MOV	NXTSID(R2),R2
	BNE	1$
3$:	CALL	MAPPTR,<#MUNLNK> ;MUNCH ALL LINKS
4$:	MOV	(SP)+,R2	;RETURN
	RTS	PC

;When MUNLNK is called, R0 is a pointer to a block which may or may not have
;been moved by CPFY.  If it has been moved, then TAG(R0) will have
;been set to 0, and WORD0(R0) will point at the correct block.
;The routine will always return a pointer to the "real" block,
;so MARKR0 will return a correct value.

MUNLNK:	TSTB	TAG(R0)		;DID WE MOVE IT ??
	BNE	1$		;
	MOV	WORD0(R0),R0	;YES, PUT NEW POINTER IN PLACE
1$:	RTS	PC		;

; SWEEP

ROUTINE SWEEP		;The sweep phase of garbage collection
	MOV	R2,-(SP)	;
	MOV	SIDLST,R2	;LIST OF SIZES
	BEQ	2$
1$:	JSR	PC,SWP.		;GO SWEEP ONE AREA
	MOV	NXTSID(R2),R2	;ITERATE
	BNE	1$		;
2$:	MOV	(SP)+,R2	;
	RTS	PC		;

ROUTINE SWEEP1,<SPCC>	
	MOV	R2,-(SP)	;SAVE REGISTERS
	MOV	SPCC(RF),R2	;GET A SPACE
	JSR	PC,SWP.		;SWEEP ONE AREA
	MOV	(SP)+,R2	
	RTS	PC

SWP.:	;R2 = LOC[Space descriptor]
	TST	GCFG(R2)	;IS THIS SPACE FOR SWEEPING??
	BNE	1$		;
	RTS	PC		;NO
1$:	MOV	R3,-(SP)	;YES
	MOV	R4,-(SP)	;
	CLR	FFREE(R2)	;WILL BUILD A REAL FREE LIST
	CLR	NFREE(R2)	;SINCE WE WILL FIX COUNTS
	CLR	NALLOC(R2)	;
	MOV	LSTBUF(R2),R3	;OLDEST BUFFER
	BEQ	6$		;IF ANY
	MOV	SIZE(R2),R4	;COMPUTE SIZE
	INC	R4		;IN BYTES OF WHOLE THING
	ASL	R4		;
2$:	MOV	LSTBLK(R3),R0	;GET A BLK
3$:	TSTB	TAG(R0)		;ALLOCATED?
	BEQ	4$		;NO
	INC	NALLOC(R2)	;YES
	BR	5$
4$:	INC	NFREE(R2)	;LINK UP A FREE
	MOV	FFREE(R2),WORD0(R0)
	MOV	R0,FFREE(R2)
5$:	SUB	R4,R0		;BUMP POINTER TO NEXT IN BUFFER
	CMP	R0,FSTBLK(R3)	;DONE BUFFER??
	BGE	3$		;NO
	MOV	PRVBUF(R3),R3	;YES GO BACK TO NEXT
	BNE	2$		;IF THERE IS ONE

	TST	CMPOK		;If we're not compacting then can't
	BNE	6$		;  release any buffers

;Here's where we release any extra buffers freed by compacting

10$:	MOV	NFREE(R2),R0
	SUB	NPERB(R2),R0	;Number free left after releasing a buffer
	CMP	R0,NMIN(R2)	;Check that there are still enough left
	BLT	6$		;Nope - 
	MOV	R0,R1
	ADD	NALLOC(R2),R1	;Now check that the percentage free is ok
	MUL	NPCT(R2),R1
	DIV	#144,R1		; NPCT*(NFREE+NALLOC)/100
	CMP	R0,R1		;Well?
	BLT	6$		;Nope -
	MOV	R0,NFREE(R2)	;Yup - release the buffer. New free count
	MOV	FFREE(R2),R1	;Now fix up the free list
	DEC	R0
	BEQ	12$
11$:	MOV	WORD0(R1),R1	;Run down free list
	SOB	R0,11$		;Till new end
12$:	CLR	WORD0(R1)	;New end of list
	MOV	LSTBUF(R2),R0	;Last buffer - the one we'll free
	MOV	PRVBUF(R0),R1	;New last buffer
	MOV	R1,LSTBUF(R2)	;Remove freed buffer from chain
	CLR	NXTBUF(R1)
	JSR	PC,RLFREE	;Release the buffer
	BR	10$		;Free as many as you can

6$:	CMP	NFREE(R2),NMIN(R2)	;NEED MORE??
	BGT	8$		;AT LEAST HAVE MIN NUMBER
7$:	CALL	ADDBUF,<R2>	;NO, ADD A BUFFER FULL
	BR	6$		;AND TRY AGAIN
8$:	MOV	NFREE(R2),R0	;SEE IF HIGH ENOUGH PERCENTAGE
	ADD	NALLOC(R2),R0	;OF FREES
	MUL	NPCT(R2),R0	; 
	DIV	#144,R0		; NPCT*(NFREE+NALLOC)/=100
	CMP	NFREE(R2),R0	;
	BGT	9$		;IF DONT HAVE ENOUGH
	CALL	ADDBUF,<R2>	;GET A BUFFER LOAD
	BR	8$		;AND TRY AGAIN
9$:	MOV	(SP)+,R4	;RESTORE
	MOV	(SP)+,R3
	RTS	PC

; GC, NOGC, YESGC, NOCMP, YESCMP

ROUTINE GC
	INC	GCDONE		;Keep track of how many times we GC
	CALL	MARKPH		;MARK EVERYONE
	TST	CMPOK		;IF DONT WANT COMPACTING
	BNE	1$		;THEN DONT DO IT
	CALL	COMPACT		;COMPACT
1$:	CALL	SWEEP		;SWEEP UP LOOSE GARBAGE
	RTS	PC

NOGC:
COMMENT ⊗ Called by anyone who has entered that stage of code
during which he does not want garbage collect to happen.  ⊗
	EVWAIT	SBEVT		;Grab exclusion
	INC	GCOK		;Increment the count of those who say nay
	EVSIG	SBEVT		;Release exclusion
	RTS	PC		;Done

YESGC:
COMMENT ⊗ Called by anyone who has exited that stage of code
during which he does not want garbage collect to happen.  ⊗

	EVWAIT	SBEVT		;Grab exclusion
	DEC	GCOK		;Remove the effect we did in NOGC.
	EVSIG	SBEVT		;Release exclusion
	BGT	1$		;Reasonable?
	ALERR	2$		;No
1$:	RTS	PC		;Yes.
2$:	ASCIE	</GCOK IS NEGATIVE/>

NOCMP:
COMMENT ⊗ Called by anyone who has entered that stage of code
during which he does not want compacting to happen.  ⊗
	EVWAIT	SBEVT		;Grab exclusion
	INC	CMPOK		;Increment the count of those who say nay
	EVSIG	SBEVT		;Release exclusion
	RTS	PC		;Done

YESCMP:
COMMENT ⊗ Called by anyone who has exited that stage of code
during which he does not want compacting to happen.  ⊗

	EVWAIT	SBEVT		;Grab exclusion
	DEC	CMPOK		;Remove the effect we did in NOGC.
	EVSIG	SBEVT		;Release exclusion
	BGT	1$		;Reasonable?
	ALERR	2$		;No
1$:	RTS	PC		;Yes.
2$:	ASCIE	</CMPOK IS NEGATIVE/>
; GETSBK, GETBLK, GETSID, PTRSID

GETSBK:	
;
;	MOV	[SPACE DESCRIPTOR],R0
;	JSR	PC,GETSBK
;	<RETURNS WITH A BLOCK IN R0>
;
	MOV	R0,R1			
GETBL:	EVWAIT	SBEVT			;CRITICAL REGION STARTS
1$:	TST	R1			;
	BEQ	GETBER			;CONSISTENCY CHECK
	MOV	FFREE(R1),R0		;R0 ← FIRST FREE BLOCK
	BNE	5$			;DID WE GET ONE
	MOV	R1,-(SP)		;NO,
	TST	GCFG(R1)		;IS GC OK FOR THIS AREA?
	BEQ	2$			;NO, MUST ADD
	TST	GCOK			;IS GARBAGE COLLECTION OK AT ALL
	BNE	2$			;no.
	; Must be able to get GNEVT and INTEVT.  Don't need them right now, though.
	EVTST	GNEVT			;We must have this available.
	BCS	2$			;
	EVSIG	GNEVT			;
	EVTST	INTEVT			;We must have this available.
	BCS	2$			;
	EVSIG	INTEVT			;
	BR 	3$			;
2$:	CALL	ADDBUF,<R1>		;NO, JUST GET A BUFFER
	BR 	4$			;
3$:	CALL	GC			;YES, GC
4$:	MOV	(SP)+,R1		;
	BR	1$
5$:	MOV	WORD0(R0),FFREE(R1)	;NEW FIRST FREE BLOCK
	INC	NALLOC(R1)		;ADJUST COUNTS
	DEC	NFREE(R1)
	MOVB	IDFLAG(R1),TAGID(R0)	;REMEMBER WHAT IT IS
	MOV	R0,-(SP)		;SAVE POINTER TO BLOCK
	MOV	SIZE(R1),R1		;WORD COUNT
6$:	CLR	(R0)+			;CLEAR A WORD
	SOB	R1,6$			;UNTIL DONE
	MOV	(SP)+,R0		;RETURN VALUE BACK
;Used to end critical section here. Now done by caller	ARG 11/76
;	EVSIG	SBEVT			;END OF CRITICAL SECTION
	RTS	PC

;
;	MOV	#ID,R0
;	JSR	PC,GETBLK
;
GETBLK:	JSR	PC,GETSID		;SET UP SPC DSCR IN R1
	BR	GETBL

GETBER:	ALERR	GERMSG
	CLR	R0
	RTS	PC

GERMSG:	ASCIE	/ATTEMPT TO ALLOCATE RECORD WITHOUT GIVING DESCRIPTOR/

GETSID:
;  Given the TAGID of a space in R0, returns LOC[space descriptor] in R1.
	MOV	R0,R1
	CMP	R0,#MAXIDF		;IN THE TABLE?
	BGT	2$			;NO
	ASL	R1
	MOV	SIDTBL(R1),R1		;YES
1$:	RTS	PC			;
2$:	MOV	SIDLST,R1		;SEARCH CHAIN
	BEQ	1$
3$:	CMP	R0,IDFLAG(R1)		;THIS ONE??
	BNE	1$			;YES
	MOV	NXTSID(R1),R1		;NO, TRY NEXT
	BNE	3$
	RTS	PC

PTRSID:
; Given a pointer to a block in R0, returns LOC[space descriptor] in R1.
; Does not destroy R0.
	MOV	R0,-(SP)		;SINCE GETSID WILL MUNCH
	MOVB	TAGID(R0),R0		;THE ID FLAG
	BIC	#177400,R0		;The sign was extended.  Clear it.
	JSR	PC,GETSID		;GET SID INTO R1
	MOV	(SP)+,R0		;GET PTR BACK
	RTS	PC
; FREBLK, FRESBK

FREBLK:
    COMMENT ⊗ To free a block whose descriptor is not known:
            MOV     BLOCK,R0        ;R0 ← Block to free
            JSR     PC,FREBLK
    ⊗
	MOV	SIDLST,R1	;FIND THE SPACE
	BEQ	2$		;THIS CAME FROM
1$:	CMPB	TAGID(R0),IDFLAG(R1) ;WAS IT THIS AREA
	BEQ	FREB.		;YES
	MOV	NXTSID(R1),R1	;NO. LOOK AT NEXT
	BNE	1$		;ITERATE
2$:	ALERR	FRERMS
	RTS	PC
FREB.:	EVWAIT	SBEVT		;CRITICAL REGION STARTS
	MOV	FFREE(R1),WORD0(R0);FOUND THE AREA, PUT ON FREE CHAIN
	MOV	R0,FFREE(R1)
	INC	NFREE(R1)	;ADJUST COUNTS
	DEC	NALLOC(R1)
	CLRB	TAG(R0)		;JUST FOR RANDOMNESS
	EVSIG	SBEVT		;END OF CRITICAL REGION
	RTS	PC		;DONE
FRERMS:	ASCIE	/ATTEMPT TO DELETE A BLOCK FROM AN AREA I CANNOT FIND/

FRESBK:
    COMMENT ⊗  To free a block whose descriptor is known:
            MOV     BLOCK,R0         ;R0 ← block to free
            MOV     #SPCDSC,R1       ;R1 ← space descriptor
            JSR     PC,FRESBK
    ⊗

	CMPB	TAGID(R0),IDFLAG(R1)	;BE SURE THIS IS OK
	BEQ	FREB.		;WE WIN
	ALERR	FREBER
	BR	FREB.		;DO IT ANYHOW IF CONTINUES IT

FREBER:	ASCIE	/ID DISAGREEMENT FOR FRESBK/
; NEWSPC, SETSPC

COMMENT ⊗ Create a space descriptor.  SZ is the size, IDF the IDFLAG,
NPB the number of blocks per buffer, GCF is set if the area is not to
be collected, NMN is the minimum number of free blocks that GC should
return, NPC is the minimum percent of free blocks that GC should
return.  R0 returns the address of the new space descriptor.  ⊗
ROUTINE NEWSPC,<SZ,IDF,NPB,GCF,NMN,NPC>

	MOV	#SPCHDR/2,R0	;GET A BLOCK OF CORE
	JSR 	PC,GTFREE
	MOV	SZ(RF),SIZE(R0) ;REMEMBER HOW BIG
	MOV	NPB(RF),NPERB(R0) ;
	MOV	IDF(RF),IDFLAG(R0) ;
	MOV	NMN(RF),NMIN(R0);
	MOV	NPC(RF),NPCT(R0);
	MOV	SIDLST,NXTSID(R0)  ;LINK ONTO ID CHAIN
	MOV	R0,SIDLST
NEWS.:	MOV	IDFLAG(R0),R1	;R1 ← space number
	CMP	R1,#MAXIDF	;WILL IT FIT INTO TABLE
	BGT	1$		;
	ASL	R1		;YES
	MOV	R0,SIDTBL(R1)	;PUT INTO TABLE
1$:	CLR	FFREE(R0)	;Zero out other things
	CLR	FSTBUF(R0)
	CLR	LSTBUF(R0)
	CLR	NALLOC(R0)
	CLR	NFREE(R0)
	RTS	PC		;RETURN

COMMENT ⊗ Initialize a space descriptor.  SPCADR is its address.  It
will be linked into the ID chanin, put in the SIDTBL if it fits, and
it will be cleared of all buffers.  ⊗
ROUTINE SETSPC,<SPCADR>
	MOV	SPCADR(RF),R0	;
	BR	NEWS.		;GO INITIALIZE ALL NON-CONSTANT THINGS
; ADDBUF

ROUTINE ADDBUF,<SPACE>
;ADDS ANOTHER BUFFER TO THE NAMED SPACE
	MOV	R2,-(SP)		;SAVE A REGISTER
	MOV	R3,-(SP)
	MOV	SPACE(RF),R2
	MOV	SIZE(R2),R1		;CALCULATE WORD REQUIREMENTS
	INC	R1			;ONE WORD OVERHEAD FOR TAG & ID BYTES
	MOV	R1,-(SP)		;WILL NEED THIS LATER
	MUL	NPERB(R2),R1		;SIZE*NUMBER OF BLOCKS
	ADD	#BUFHDR/2,R1		;
	MOV	R1,R0			;
	JSR	PC,GTFREE		;GET A BLOCK
	MOV	LSTBUF(R2),R1		;LINK ONTO CHAIN
	MOV	R1,PRVBUF(R0)		;LINK BACK
	BEQ	1$			;
	MOV	R0,NXTBUF(R1)		;AND PERHAPS FORWARD
	BR	2$			;
1$:	MOV	R0,FSTBUF(R2)		;IF WAS NO LSTBUF, THEN THIS IS FSTBUF
2$:	CLR	NXTBUF(R0)		;CLEAN UP
	MOV	R0,LSTBUF(R2)		;NEW NEWEST BLOCK
	MOV	R0,R3			;
	ADD	#2+BUFHDR,R3		;POINTER AT FIRST BLOCK
	MOV	R3,FSTBLK(R0)		;REMEMBER IT
	MOV	NPERB(R2),R1		;
	ADD	R1,NFREE(R2)		;New free count
	ASL	(SP)			;NUMBER OF BYTES TO STEP BY

3$:	CLRB	TAG(R3)			;CLEAR TAG
	MOVB	IDFLAG(R2),TAGID(R3)	;SET TYPE ID
	MOV	R3,WORD0(R3)		;
	ADD	(SP),WORD0(R3)		;Point to next block
	MOV	WORD0(R3),R3
	SOB	R1,3$			;ITERATE if any left

	SUB	(SP)+,R3		;Point to last block
	MOV	R3,LSTBLK(R0)		;R3 NOW POINTS AT LAST BLOCK
	CLR	WORD0(R3)		;End of free list
	MOV	FFREE(R2),R3		;Find end of free list
	BNE	4$			; If any
	MOV	FSTBLK(R0),FFREE(R2)	;Set up new free list
	BR	5$
4$:	MOV	R3,R2			;Chase through free list
	MOV	WORD0(R3),R3
	BNE	4$			; Til end
	MOV	FSTBLK(R0),WORD0(R2)	;Add new blocks to end of free list

5$:	MOV	(SP)+,R3		;RESTORE ACS
	MOV	(SP)+,R2
	RTS	PC

; Standard spaces, SBINIT, Marking methods: MCELL, MARKQ

;Recall that MACRO DEFSPC ID,MMRT,SZ,NPB,GCF,NMN,NPC

SCASPC:	DEFSPC	SCLID,MKRTJM,2,10,1,4,15
VCTSPC:	DEFSPC	VCTID,MKRTJM,10,10,1,4,15
TRNSPC:	DEFSPC	TRNID,MKRTJM,30,4,1,2,15
CELSPC:	DEFSPC	CELID,MKRTJM,2,10,1,4,15
ENVSPC:	DEFSPC	ENVID,MKRTJM,30,3,1,1,10

COMMENT ⊗ Thus SCLID=1, VCTID=2, TRNID=3 ⊗

ROUTINE SBINIT
; Initializes the small block allocator with the standard spaces.
	EVMAK			;Initialize the small block interlock event
	MOV (SP)+,SBEVT		;
	EVSIG SBEVT		;
	MOV #SIDHED,SIDLST	;
	CLR GCOK		;Garbage collect initially OK.
	CLR GCDONE		;
	MOV #SIDHED,R2		;R2 ← First space
	BEQ 2$			;If any
1$:	CALL SETSPC,<R2>	;Initialize this space
	MOV NXTSID(R2),R2	;R2 ← Next space
	BNE 1$			;If any
2$:	CLR MMETHS		;Initialize the marking methods
	MOV #MGNDSM,R0		;Link in the GNODE marking method
	JSR PC,LNKMTH		;
	MOV #MINTSM,R0		;Link in the interpreter stack marking method
	JSR PC,LNKMTH		;
	RTS PC

MGNDSM:	MMETH MGNDS		;In file GRAPHS.PAL
	
MINTSM:	MMETH MINTS		;In file INTERP.PAL

MCELL:	
COMMENT ⊗ Marking method for a cell list.  Takes pointer to list in
R0, and marks all the way down, and returns pointer in R0, since
compacting may move it.  ⊗
	TST R0			;Empty?
	BEQ 2$			;Yes.
	MOV R2,-(SP)		;Save R2
	JSR PC,MARKQ		;Mark cell
	MOV R0,-(SP)		;Save list header
1$:	MOV R0,R2		;Save new pointer
	MOV CDR(R2),R0		;Mark the rest of the list iteratively
	JSR PC,MARKQ		;Mark this cell
	MOV R0,CDR(R2)		;replace pointer.
	BNE 1$			;Loop til end of list
	MOV (SP)+,R0		;Restore R0 ← pointer
	MOV (SP)+,R2		;Restore R2
2$:	RTS PC			;Done

MARKQ:
COMMENT ⊗ R0 holds LOC[small block].  Mark it if it is really a small
block; but be careful, since it may be a constant.  Return it in R0,
since compacting may have moved it.  ⊗
	CMP R0,#FREEST	;Make sure that it points into free storage.
	BLE 1$		; (it may be a program constant)
	CMP R0,#FREEND	;
	BGE 1$		;
	JSR PC,MARKR0	;Get it marked
1$:	RTS PC		;Done

.IFNZ	SMBDBG		;Test routine


FSTEST:	CALL	SBINIT
	MOV	#20,R2
	MOV	#VCTARA,R3
FST.1:	MOV	#VCTID,R0
	JSR	PC,GETBLK
FST.2:	MOV	R0,(R3)+
	DEC	R2
	BGT	FST.1
FST.3:	MOV	#13,R2
FST.4:	MOV	-(R3),R0
	JSR	PC,FREBLK
	DEC	R2
	BGT	FST.4
FST.5:	MOV	#17,R2
FST.6:	MOV	#VCTID,R0
	JSR	PC,GETBLK
	MOV	R0,(R3)+
	DEC	R2
	BGT	FST.6
FST.10:	MOV	#TSTMTH,R0
	JSR	PC,LNKMTH
	MOV	R3,VCTUB
	SUB	#2,VCTUB
	MOV	#VCTARA,VCTLB
	MOV	#-1,GCOK
	CALL	GC
FST.11:	MOV	#10,R2
FST.12:	MOV	#VCTSPC,R0
	JSR	PC,GETSBK
	DEC	R2
	BGT	FST.12

	ALERR	DNMSG

DNMSG:	ASCIE	</
WELL HOW DID WE DO?/>

VCTARA:	.BLKW	200
VCTUB:	0
VCTLB:	0

TSTMTH:	MMETH	TSTRTN

ROUTINE TSTRTN,<RTN>
	MOV	R2,-(SP)
	MOV	VCTLB,R2
TST.R1:	CMP	R2,VCTUB
	BGT	TSTRTS
	MOV	(R2),R0
	JSR	PC,MARKR0
	MOV	R0,(R2)+
	BR	TST.R1
TSTRTS:	MOV	(SP)+,R2
	RTS	PC

.ENDC
; Known bugs

COMMENT ⊗ Garbage collect will fail to mark, and therefore wrongfully
collect, those small blocks which have just been allocated and are
sitting in registers somewhere.  The proper fix to this is that
GETSBK and GETBLK should turn on one level of garbage collect
inhibition, and let the caller turn it off when he has stowed away
the pointer in some place known to the marking routines. (This has
been done using SBEVT to do the interlocking. ARG 11/76)  A similar
problem could occur when someone removes a pointer from the known
places before he is really finished with the small block.  This is
fixed only by careful identification and rectification of such pieces
of code.  

When marking those things pointed to by interpeter stacks, the MINT
routine looks for a zero entry on the stack.  This could fail, or get
more than wanted. (Should be okay now. Interp keeps sticking a zero
on the top just prior to interpreting the next pseudo-code instruction.)
⊗